home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Workbench Add-On
/
Workbench Add-On - Volume 1.iso
/
BBS-Archive
/
Dev
/
GNU-TILE-FORTH.lha
/
lib
/
mappings.f83
< prev
next >
Wrap
Text File
|
1992-05-19
|
3KB
|
142 lines
\
\ MAPPINGS IN VECTOR REPRESENTATION
\
\ Copyright (C) 1990 by Mikael R.K. Patel
\
\ Computer Aided Design Laboratory (CADLAB)
\ Department of Computer and Information Science
\ Linkoping University
\ S-581 83 LINKOPING
\ SWEDEN
\
\ Email: mip@ida.liu.se
\
\ Started on: 6 August 1990
\
\ Last updated on: 7 August 1990
\
\ Dependencies:
\ (forth) forth, blocks
\
\ Description:
\ Management of mappings represented as a vector of cells. The
\ mapping consists of pairs of values; domain and range and
\ is terminated by the double value zero (nil). Thus double zero
\ cannot be a member of mapping. Used mainly for extra values bound
\ to entries when field space has not been allocated.
\
\ Copying:
\ This program is free software; you can redistribute it and\or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 1, or (at your option)
\ any later version.
\
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with this program; see the file COPYING. If not, write to
\ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
.( Loading Mappings definitions...) cr
#include blocks.f83
vocabulary mappings ( -- )
blocks mappings definitions
0 field +domain ( mapping -- addr) private
cell field +range ( mapping -- addr) private
2 cells field +pair ( mapping -- addr) private
: mapping ( size -- )
create 0 0 here 2! 2* cells allot
;
: empty-mapping ( mapping -- )
0 0 rot 2!
;
: ?empty-mapping ( mapping -- bool)
2@ or boolean not
;
: size-mapping ( mapping -- num)
0 swap
begin
dup 2@ or
while
swap 1+ swap +pair
repeat
drop
;
: search-mapping ( domain mapping -- [addr1] or [domain addr2 false])
swap >r
begin
dup 2@ or
while
dup +domain @ r@ =
if r> drop exit then
+pair
repeat
r> swap false
; private
: add-mapping ( range domain mapping -- )
search-mapping ?dup if +range ! else dup 0 0 rot +pair 2! 2! then
;
: remove-mapping ( domain mapping -- )
search-mapping ?dup
if
begin
dup +pair tuck
2@ 2dup or boolean not >r rot 2! r>
until
drop
else
2drop
then
;
: ?range-mapping ( domain mapping -- bool)
search-mapping if true else 2drop false then
;
: range-mapping ( domain mapping -- addr)
search-mapping ?dup if +range else 2drop nil then
;
: map-mapping ( mapping block[range domain -- ] -- )
>r
begin
dup 2@ 2dup or
while
rot r@ swap >r call r> +pair
repeat
r> 2drop 2drop
;
: ?map-mapping ( mapping block[range domain -- bool] -- )
>r
begin
dup 2@ 2dup or
while
rot r@ swap >r call r> swap if r> 2drop exit then +pair
repeat
r> 2drop 2drop
;
: .mapping ( mapping -- )
." { "
block[ ( range domain -- ) ." ( " .name space . ." ) " ];
map-mapping
." } "
;
forth only